home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HPAVC
/
HPAVC CD-ROM.iso
/
AFVIEW.ZIP
/
AFVIEW.PAS
next >
Wrap
Pascal/Delphi Source File
|
1995-03-01
|
13KB
|
387 lines
program afVIEW;
{$M $4000, 0, 0}
uses crt,dos;
type
SegOfs = record {structure of a pointer}
Ofst, Segm : Word;
end;
function Normalized(P : Pointer) : pointer; inline
($58/ {pop ax ;pop offset into AX}
$5A/ {pop dx ;pop segment into DX}
$89/$C3/ {mov bx,ax ;BX = Ofs(P^)}
$B1/$04/ {mov cl,4 ;CL = 4}
$D3/$EB/ {shr bx,cl ;BX = Ofs(P^) div 16}
$01/$DA/ {add dx,bx ;add BX to segment}
$25/$0F/$00); {and ax,$F ;mask out unwanted bits in offset}
function Linear(P : Pointer) : LongInt;
{-Converts a pointer to a linear address to allow differences in addresses
to be calculated. The pointer must be in the range $0:$0 to $FFFF:$000F.}
begin
with SegOfs(P) do
Linear := (LongInt(Segm) shl 4)+LongInt(Ofst);
end;
function LinearToPointer(L : LongInt) : Pointer;
{-Return linear address L as a normalized pointer}
begin
LinearToPointer := Ptr(Word(L shr 4), Word(L and $0000000F));
end;
function PtrDiff(P1, P2 : Pointer) : LongInt;
{-Return the number of bytes between P1^ and P2^}
begin
PtrDiff := Abs(Linear(P1)-Linear(P2));
end;
procedure HugeGetMem(var Pt; Bytes : LongInt);
var
P : Pointer absolute Pt;
So : SegOfs absolute P;
Paras : word;
begin
P:=Nil;
Paras:=Bytes div 16;
asm
mov bx, Paras
mov ah, 48h
int 21h
mov Paras, 0
jc @end
mov Paras, ax
@end:
end;
if Paras > 0 then So.Segm:=Paras;
end;
procedure HugeFreeMem(var Pt; Bytes : LongInt);
{-Deallocate a block of memory of size Bytes pointed to by Pt, a pointer
variable. Pt is set to nil on Exit. Does nothing if Pt is nil.}
var
P : Pointer absolute Pt;
So : SegOfs absolute P;
Tmp:word;
begin
{exit if P is nil}
if (P = nil) then
Exit;
Tmp:=So.Segm;
asm
mov es, Tmp
mov ah, 49h
int 21h
end;
end;
procedure FillWord(var x; count:integer; w:word);
begin
Inline(
$c4/$be/x/
$8b/$86/w/
$8b/$8e/count/
$fc/
$f2/$ab);
(* LES DI,x { load target address }
MOV AX,w { load word to fill in }
MOV CX,count { number of words to move }
CLD { clear direction flag }
REPNZ STOSW { copy the data } *)
end;
procedure LoadFile(FileN:string; Mem:pointer; NumL:word; var MaxLine:word);
var
CurLine:word;
Tmp2:byte;
TFileIn:file;
AbsPtr:longint;
TmpPtr:longint;
TmpStr:array[1..8192] of char;
Actual:word;
Tmp:word;
TmpBuf:pointer;
Attr:byte; X,Y,SX,SY:word;
AnsiLevel:byte;
ParamCnt:byte;
Params:array[1..10] of byte;
procedure PutCh(Ch:char);
begin
case Ch of
#8: begin
if x>1 then
begin
dec(X);
TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
char(LinearToPointer(TmpPtr)^):=' ';
byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
end;
end;
#10: begin
if Y < (NumL-1) then inc(Y);
end;
#13: begin
X:=1;
end;
#1..#7,#11,#14..#255:
begin
TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
char(LinearToPointer(TmpPtr)^):=Ch;
byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
inc(x); if X > 80 then begin X:=1; inc(Y); if y > (NumL-1) then dec(y) end;
end;
end;
end;
procedure SetColors;
var
Cntr : byte;
begin
for Cntr := 1 to ParamCnt do
begin
case Params[Cntr] of
0 : TextAttr := $07;
1 : TextAttr:=TextAttr or $08;{asm or Attr, 08h end;}
5 : TextAttr:=TextAttr or $80;{asm or Attr, 80h end;}
7 : asm
mov ax, word ptr TextAttr
mov bx, ax
and ax, 0707h
xchg ah, al
and bx, 80h
add ax, bx
mov word ptr TextAttr, bx
end;
25 : TextAttr := (TextAttr AND (NOT $80)); {blink off}
30 : TextAttr := (TextAttr AND $F8) + black;
31 : TextAttr := (TextAttr AND $f8) + red;
32 : TextAttr := (TextAttr AND $f8) + green;
33 : TextAttr := (TextAttr AND $f8) + brown;
34 : TextAttr := (TextAttr AND $f8) + blue;
35 : TextAttr := (TextAttr AND $f8) + magenta;
36 : TextAttr := (TextAttr AND $f8) + cyan;
37 : TextAttr := (TextAttr AND $f8) + Lightgray;
40 : TextAttr := (TextAttr AND $8F) + (black shl 4);
41 : TextAttr := (TextAttr AND $8F) + (red shl 4);
42 : TextAttr := (TextAttr AND $8F) + (green shl 4);
43 : TextAttr := (TextAttr AND $8F) + (brown shl 4);
44 : TextAttr := (TextAttr AND $8F) + (blue shl 4);
45 : TextAttr := (TextAttr AND $8F) + (magenta shl 4);
46 : TextAttr := (TextAttr AND $8F) + (cyan shl 4);
47 : TextAttr := (TextAttr AND $8F) + (lightgray shl 4);
end;
end;
end;
begin
Assign(TFileIn,FileN);
Reset(TFileIn,1);
AbsPtr:=Linear(Mem);
for CurLine:=0 to NumL-1 do
begin
FillWord(LinearToPointer(AbsPtr+(longint(CurLine)*160))^,80,$0720);
end;
CurLine:=0;
TextAttr:=$07;
X:=1; Y:=1; AnsiLevel:=0; MaxLine:=1;
repeat
{ReadLn(TFileIn, TmpStr);}
BlockRead(TFileIn, TmpStr, 4096, Actual);
for Tmp:=1 to Actual do
begin{
TmpPtr:=AbsPtr+(longint(CurLine)*160)+(Tmp*2);
char(LinearToPointer(TmpPtr)^):=TmpStr[Tmp+1];
byte(LinearToPointer(TmpPtr+1)^):=$0F;}
if TmpStr[Tmp]=#26 then break;
case ANSILevel of
0: begin
case TmpStr[Tmp] of
#27: ANSILevel := 1;
#9: if X < 80-8 then X:=( (X div 8) + 1 ) * 8;
else
PutCh(TmpStr[Tmp]);
end;
end;
1: begin
if TmpStr[Tmp] = '[' then
begin
ANSILevel := 2;
ParamCnt := 1;
Params[1] := 0;
end
else
begin
{Write(#27+StIn[Cntr]);}
PutCH(TmpStr[Tmp]);
ANSILevel := 0;
end;
end;
2: begin
case TmpStr[Tmp] of
'0'..'9': Params[ParamCnt]:=(Params[ParamCnt]*10)+(byte(TmpStr[Tmp])-48);
';': begin
inc(ParamCnt);
Params[ParamCnt] := 0;
end;
'H',
'f': begin
if Params[2] > 80 then x:=80 else x:=Params[2];
if Params[1] > (NumL-1) then y:=NumL-1 else y:=Params[1];
ANSILevel := 0;
end;
'A': begin
if Params[1] = 0 then Params[1] := 1;
if (Y - Params[1]) < 1 then Y:=1 else Y:=Y - Params[1];
ANSILevel := 0;
end;
'B': begin
if Params[1] = 0 then Params[1] := 1;
if (Y + Params[1]) > (NumL-1) then Y:=NumL-1 else Y:=Y+Params[1];
ANSILevel := 0;
end;
'D': begin
if Params[1] = 0 then Params[1] := 1;
if (X - Params[1]) < 1 then X:=1 else X:=X - Params[1];
ANSILevel := 0;
end;
'C': begin
if Params[1] = 0 then Params[1] := 1;
if (X + Params[1]) > 80 then X:=80 else X:=X+Params[1];
ANSILevel := 0;
end;
'J': begin
case Params[1] of
0: for Tmp2:=X to 80 do
begin
TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((Tmp2-1)*2);
char(LinearToPointer(TmpPtr)^):=' ';
byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
end;
1, {I just didn't bother today.}
2: begin
for CurLine:=0 to NumL-1 do
FillWord(LinearToPointer(AbsPtr+(longint(CurLine)*160))^,80,$0720);
x:=1; y:=1;
end;
end;
ANSILevel := 0;
end;
'K': begin
for Tmp2:=X to 80 do
begin
TmpPtr:=AbsPtr+((longint(Y)-1)*160)+((X-1)*2);
char(LinearToPointer(TmpPtr)^):=' ';
byte(LinearToPointer(TmpPtr+1)^):=TextAttr;
end;
ANSILevel := 0;
end;
'm': begin
SetColors;
ANSILevel := 0;
end;
's': begin
SX:=X; SY:=Y;
ANSILevel := 0;
end;
'u': begin
X:=SX; Y:=SY;
ANSILevel := 0;
end;
end;
end;
end;
end;
if y>MaxLine then MaxLine:=y;
until eof(TFileIn) or (actual<4096);
Close(TFileIn);
end;
procedure Scroll(Ptr:pointer; NumL:word);
var
Done:boolean;
CurLine:word;
CurPtr:longint;
begin
Done:=False;
CurPtr:=Linear(Ptr);
CurLine:=0;
TextAttr:=$7;
ClrScr;
repeat
Move(LinearToPointer(CurPtr+(longint(CurLine)*160))^,Mem[$B800:$0000],160*25);
GotoXY(77,1);
Write(CurLine:4);
case ReadKey of
#0: case ReadKey of
#71: CurLine:=0;
#72: if CurLine>0 then dec(CurLine);
#73: if (integer(CurLine)-25)>0 then dec(CurLine,25) else CurLine:=0;
#79: CurLine:=NumL-25;
#80: if CurLine+25<NumL then inc(CurLine);
#81: if (CurLine+25+25)<NumL then inc(CurLine,25) else CurLine:=NumL-25;
end;
#27: Done:=True;
end;
until Done;
end;
var videopage : byte;
{$L CurShape.OBJ}
function getcursorshape : word; far; external;
procedure setcursorshape(scanlines : word); far; external;
procedure normalcursor;
begin
setcursorshape($0607);
end;
procedure hidecursor;
begin
setcursorshape($2000);
end;
var
LngInt:longint;
TmpPtr:pointer;
NumLines:word;
FileName:string;
D : DirStr;
N : NameStr;
E : ExtStr;
const
BuffLines=1500;
BuffSize=BuffLines*160;
begin
videopage:=0;
WriteLn('afVIEW -- 1500 line Real Mode ANSi');
WriteLn('viewer by FAT Slayer [CiA/afSOFT]');
if ParamCount<>1 then
begin
WriteLn(^J'Incorrect syntax, correct syntax:'^M^J^J' AFVIEW FileName[.Ext]'^M^J^J+
'The extension is optional and will be assumed to be .ANS');
Halt(1);
end;
FileName:=ParamStr(1);
FSplit(FileName,D,N,E);
if E='' then FileName:=FileName+'.ANS';
if FSearch(FileName,'')='' then
begin
WriteLn(ParamStr(1),' not found.');
Halt(1);
end;
HugeGetMem(TmpPtr,BuffSize);
if TmpPtr=nil then begin WriteLn('Memory allocation error.'); halt; end;
LoadFile(ParamStr(1),TmpPtr,BuffLines,NumLines);
HideCursor;
Scroll(TmpPtr,NumLines);
NormalCursor;
HugeFreeMem(TmpPtr,0);
TextAttr:=$07;
ClrScr;
WriteLn('afVIEW -- 1500 line Real Mode ANSi');
WriteLn('viewer by FAT Slayer [CiA/afSOFT]');
end.